home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / keydef.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  17.1 KB  |  412 lines
  1. ;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:8.; Fonts:CPTFONT -*-
  2.  
  3. ;;; (C) Copyright 1985 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; Permission to use, copy, modify, distribute, and sell this software
  6. ;;; and its documentation for any purpose is hereby granted without fee,
  7. ;;; provided that the above copyright notice appear in all copies and that
  8. ;;; both that copyright notice and this permission notice appear in
  9. ;;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;;; advertising or publicity pertaining to distribution of the software
  11. ;;; without specific, written prior permission.  M.I.T. makes no
  12. ;;; representations about the suitability of this software for any
  13. ;;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;;
  15.  
  16. ;;;;KEY-NAMES
  17.  
  18. ;;; This file defines :BOXER-FUNCTION names for the various keystrokes and
  19. ;;; mouse clicks the user can type. This file just defines names for those
  20. ;;; keys, other files (COMx) should do DEFBOXER-FUNCTIONs to define what
  21. ;;; those keys should do. In terms of ZWEI, this file is below the level
  22. ;;; of COMTABs (more at the level of kbd-convert-to-software-char) and the
  23. ;;; files which do the DEFBOXER-FUNCTIONs are at the level of COMTABs.
  24.  
  25. ;;; In order to provide fast conversion of LISPM character codes to
  26. ;;; BOXER key names, we use an array to look them up in. This is kind
  27. ;;; of like ZWEI.
  28.  
  29. (DEFVAR KEY-NAMES (MAKE-ARRAY '(#-TI 170. #+TI 190. 16.))
  30.   "KEY-NAMES is an art-q array of dimensions 170. by 16.. It is used
  31.    to assign symbol names to keys on the keyboard. An array is used so
  32.    that when a key is pressed the symbol name for the key can be found
  33.    more quickly.")
  34.  
  35. (DEFVAR MOUSE-CLICK-NAMES (MAKE-ARRAY '(3. 2. 16.))
  36.   "MOUSE-CLICK-NAMES is the symbolic dispatch table for mouse clicks.  The first dimension
  37.    specifies the position (L = 0, M = 1, R = 2), the second position specifies the
  38.    number of times the mouse was clicked (minus 1, i.e. #/mouse-r-2 would be a 1) and
  39.    the last dimension specifies any shifts (i.e. ctrl, meta, etc.)")
  40.  
  41. (DEFVAR MOUSE-STATE-NAMES (MAKE-ARRAY '(3. 2. 16.))
  42.   "MOUSE-CLICK-NAMES is the symbolic dispatch table for mouse states.  The first dimension
  43.    specifies the position (L = 0, M = 1, R = 2), the second position specifies the
  44.    state of the mouse (0 = down, 1 = up) and the last dimension specifies any 
  45.    shifts (i.e. ctrl, meta, etc.)")
  46.  
  47. (DEFVAR *BOXER-KEYSTROKE-HISTORY* NIL
  48.   "A list of all the keys pressed. ")
  49.  
  50. (DEFVAR *BOXER-COMMAND-KEY-ALIST* NIL
  51.   "An association list of key names and command names. ")
  52.  
  53. (DEFUN DEFINE-KEY-NAME (KEY-NAME KEY-CODE)
  54.   (COND ((NUMBERP KEY-CODE)
  55.      (ASET KEY-NAME
  56.            KEY-NAMES
  57.            (LDB %%KBD-CHAR KEY-CODE) (LDB %%KBD-CONTROL-META KEY-CODE)))
  58.     ((SYMBOLP KEY-CODE)
  59.      (FERROR "~%Can't store symbols in key-names.~
  60.                   ~%In order to teach Boxer how to handle a new kind of symbol~
  61.                   ~%in its input buffer you should define a function to handle~
  62.                   ~%the symbol on the symbol's :BOXER-INPUT property. When Boxer~
  63.                   ~%sees that symbol in its input buffer it will call that function~
  64.                   ~%with the symbol as its only argument."))
  65.     ((LISTP KEY-CODE)
  66.      (FERROR "~%Can't store blips in key-names.~
  67.                   ~%In order to teach the editor how to handle a new kind of blip in~
  68.                   ~%in its input buffer you should define a function to handle the~
  69.                   ~%blip on the :BOXER-INPUT property of the symbol which is the car~
  70.                   ~%of the blip. When Boxer sees a blip with that symbol as its car~
  71.                   ~%in its input buffer it will call that function with the blip as~
  72.                   ~%its only argument."))
  73.     (T
  74.      (FERROR "~S is a completely unknown type of Boxer Input." KEY-CODE))))
  75.  
  76. (DEFUN LOOKUP-KEY-NAME (KEY-CODE)
  77.   (AND (FIXNUMP KEY-CODE)
  78.        (>= (LDB %%KBD-CHAR KEY-CODE) 0)
  79.        (<= (LDB %%KBD-CHAR KEY-CODE) #-TI 169. #+TI 189.)
  80.        (>= (LDB %%KBD-CONTROL-META KEY-CODE) 0)
  81.        (<= (LDB %%KBD-CONTROL-META KEY-CODE) 15.)
  82.        (AREF KEY-NAMES (LDB %%KBD-CHAR KEY-CODE)
  83.                (LDB %%KBD-CONTROL-META KEY-CODE))))
  84.  
  85.  
  86.  
  87. (DEFVAR BU:*KEY-CODE-BEING-HANDLED* NIL)
  88.  
  89. (DEFVAR BU:*KEY-NAME-BEING-HANDLED* NIL)
  90.  
  91. (DEFUN HANDLE-BOXER-INPUT (INPUT)
  92.   (increment-key-tick)                ;for use with multiple-kill hack
  93.   (PUSH INPUT *BOXER-KEYSTROKE-HISTORY*)
  94.   (COND ((FIXNUMP INPUT)
  95.      ;; Some sort of Lispm key code. Try to lookup a name for it. If it
  96.      ;; has a name BOXER-FUNCALL that name with the special variables:
  97.      ;;   BU:*KEY-CODE-BEING-HANDLED* bound to the key code
  98.      ;;   BU:*KEY-NAME-BEING-HANDLED* bound to the key name
  99.      (LET ((KEY-NAME (LOOKUP-KEY-NAME INPUT)))
  100.        (COND ((AND (NOT-NULL KEY-NAME) (BOXER-FDEFINED? KEY-NAME))
  101.           (LET ((BU:*KEY-CODE-BEING-HANDLED* INPUT)
  102.             (BU:*KEY-NAME-BEING-HANDLED* KEY-NAME))
  103.             (BOXER-FUNCALL KEY-NAME)))
  104.          (T
  105.           (UNHANDLED-BOXER-INPUT INPUT)))))
  106.     ((SYMBOLP INPUT)
  107.      ;; Some sort of symbol in the input stream.
  108.      (LET ((HANDLER (GET INPUT ':BOXER-INPUT)))
  109.        (COND ((NOT-NULL HANDLER)
  110.           (LET ((BU:*KEY-CODE-BEING-HANDLED* NIL)
  111.             (BU:*KEY-NAME-BEING-HANDLED* NIL))
  112.           (FUNCALL HANDLER INPUT)))
  113.          (T
  114.           (UNHANDLED-BOXER-INPUT INPUT)))))
  115.     ((LISTP INPUT)
  116.      ;; Some sort of a blip in the input stream. Usually this is a mouse
  117.      ;; click, although it can be anything.
  118.      (LET ((HANDLER (GET (CAR INPUT) ':BOXER-INPUT)))
  119.        (COND ((NOT-NULL HANDLER)
  120.           (LET ((BU:*KEY-CODE-BEING-HANDLED* NIL)
  121.             (BU:*KEY-NAME-BEING-HANDLED* NIL))
  122.           (FUNCALL HANDLER INPUT)))
  123.          (T
  124.           (UNHANDLED-BOXER-INPUT INPUT)))))))
  125.  
  126. (DEFUN UNHANDLED-BOXER-INPUT (IGNORE)
  127.   ;; For now just be obnoxious
  128.   (BEEP))
  129.  
  130.  
  131.  
  132.  
  133. (DEFUN DEFINE-KEY-AND-ALL-ITS-SHIFTED-KEY-NAMES (KEY-NAME KEY-CODE)
  134.   (LET* ((C-KEY-NAME   (INTERN-IN-BU-PACKAGE (FORMAT NIL "CTRL-~A" KEY-NAME)))
  135.      (M-KEY-NAME   (INTERN-IN-BU-PACKAGE (FORMAT NIL "META-~A" KEY-NAME)))
  136.      (C-M-KEY-NAME (INTERN-IN-BU-PACKAGE (FORMAT NIL "CTRL-META-~A" KEY-NAME)))
  137.      
  138.      (C-KEY-CODE   (DPB 1 %%KBD-CONTROL-META KEY-CODE))
  139.      (M-KEY-CODE   (DPB 2 %%KBD-CONTROL-META KEY-CODE))
  140.      (C-M-KEY-CODE (DPB 3 %%KBD-CONTROL-META KEY-CODE)))
  141.     (DEFINE-KEY-NAME KEY-NAME     KEY-CODE)
  142.     (DEFINE-KEY-NAME C-KEY-NAME   C-KEY-CODE)
  143.     (DEFINE-KEY-NAME M-KEY-NAME   M-KEY-CODE)
  144.     (DEFINE-KEY-NAME C-M-KEY-NAME C-M-KEY-CODE)))
  145.  
  146. (EVAL-WHEN (LOAD) 
  147.   
  148.   ;; Give names to all the standard character keys. (A - Z) The upper and lower
  149.   ;; case versions of these keys both share the same name, so a function bound
  150.   ;; to that key will need to look at BU:*KEY-CODE-BEING-HANDLED* if it wants
  151.   ;; to know whether the uppercase or lowercase key was typed.
  152.   (LOOP FOR KEY-CODE FROM 101 TO 132
  153.     FOR KEY-NAME = (INTERN-IN-BU-PACKAGE (FORMAT NIL "~C-KEY" KEY-CODE))
  154.     DO
  155.      (DEFINE-KEY-AND-ALL-ITS-SHIFTED-KEY-NAMES KEY-NAME KEY-CODE)
  156.      (DEFINE-KEY-AND-ALL-ITS-SHIFTED-KEY-NAMES KEY-NAME (+ KEY-CODE 40)))
  157.  
  158.   ;; Now give names to all the rest of the keys that we can use the format ~C
  159.   ;; directive to get a name for. Basically these are all the random single
  160.   ;; symbol things on the keyboard like ! @ # ~ : etc.
  161.   (LOOP FOR KEY-CODE FROM 0 TO #O177
  162.     UNLESS (OR (AND (>= KEY-CODE 101) (<= KEY-CODE 132))
  163.            (AND (>= KEY-CODE 141) (<= KEY-CODE 172)))
  164.     DO
  165.      (DEFINE-KEY-AND-ALL-ITS-SHIFTED-KEY-NAMES
  166.        (INTERN-IN-BU-PACKAGE (FORMAT NIL "~C-KEY" KEY-CODE))
  167.        KEY-CODE))
  168.   
  169.   
  170.   ;; Give names to all the keys that we can't use the format ~C directive
  171.   ;; to get a name for. Basically these are keys like SPACE, RUBOUT etc.
  172.   ;; Now I know that there is a place in zwei, where it knows how to do
  173.   ;; this, and that I could use that if I wanted to, but I would like this
  174.   ;; to work in the next system release.
  175.   (LOOP FOR KEY-THAT-FORMAT-~C-LOSES-ON IN '((BU:SPACE-KEY        #\SPACE)
  176.                          (BU:RETURN-KEY       #\RETURN)
  177.                          (BU:RUBOUT-KEY       #\RUBOUT)
  178.                          (BU:BREAK-KEY        #\BREAK)
  179.                          (BU:HELP-KEY         #\HELP)
  180.                          (BU:LINE-KEY         #\LINE)
  181.                          (BU:END-KEY          #\END)
  182.                          (BU:CLEAR-INPUT-KEY  #\CLEAR-INPUT)
  183.                        #-3600(BU:STATUS-KEY       #\STATUS)
  184.  
  185.                        #+CADR(BU:ALTMODE-KEY      #\ALTMODE)
  186.                        #+3600(BU:COMPLETE-KEY     #\COMPLETE)
  187.                        #+3600(BU:ESCAPE-KEY     #\ESCAPE)
  188.                        #+TI  (BU:ESCAPE-KEY       #\ESCAPE)
  189.                          
  190.                        #-3600(BU:CLEAR-SCREEN-KEY #\CLEAR-SCREEN)
  191.                        #+3600(BU:PAGE-KEY         #\PAGE)
  192.  
  193.                              (BU:QUOTE-KEY        #\QUOTE)
  194.                        
  195.                        #+CADR(BU:ROMAN-I-KEY      #\ROMAN-I)
  196.                        #+CADR(BU:ROMAN-II-KEY     #\ROMAN-II)
  197.                        #+CADR(BU:ROMAN-III-KEY    #\ROMAN-III)
  198.                        #+CADR(BU:ROMAN-IV-KEY     #\ROMAN-IV)
  199.  
  200.                        #+TI  (BU:UNDO-KEY         #\UNDO)
  201.                        #+TI  (BU:F1-KEY           #\F1)
  202.                        #+TI  (BU:F2-KEY           #\F2)
  203.                        #+TI  (BU:F3-KEY           #\F3)
  204.                        #+TI  (BU:F4-KEY           #\F4)
  205.                        
  206.                        #+CADR(BU:HAND-DOWN-KEY    #\HAND-DOWN)
  207.                        #+CADR(BU:HAND-UP-KEY      #\HAND-UP)
  208.                        #+CADR(BU:HAND-LEFT-KEY    #\HAND-LEFT)
  209.                        #+CADR(BU:HAND-RIGHT-KEY   #\HAND-RIGHT)
  210.                                        #+3600 (BU:SQUARE-KEY       #\SQUARE)
  211.                                        #+3600 (BU:SCROLL-KEY       #\SCROLL)
  212.                        #+3600 (BU:CIRCLE-KEY       #\CIRCLE)
  213.                            #+3600 (BU:TRIANGLE-KEY     #\TRIANGLE)
  214.                              )
  215.     DO (DEFINE-KEY-AND-ALL-ITS-SHIFTED-KEY-NAMES
  216.          (CAR  KEY-THAT-FORMAT-~C-LOSES-ON)
  217.          (CADR KEY-THAT-FORMAT-~C-LOSES-ON)))
  218.   )
  219.  
  220.  
  221.  
  222. ;;; Give Boxer-Function Names to all the standard mouse-clicks
  223.  
  224. (DEFUN LOOKUP-CLICK-NAME (CLICK &OPTIONAL (COMTAB MOUSE-CLICK-NAMES))
  225.   (AND (FIXNUMP CLICK)
  226.        (>= (LDB %%KBD-MOUSE-BUTTON CLICK) 0)
  227.        (<= (LDB %%KBD-MOUSE-BUTTON CLICK) 2.)
  228.        (>= (LDB %%KBD-CONTROL-META CLICK) 0)
  229.        (<= (LDB %%KBD-CONTROL-META CLICK) 15.)
  230.        (AREF COMTAB (LDB %%KBD-MOUSE-BUTTON CLICK)
  231.                 (LDB %%KBD-MOUSE-N-CLICKS CLICK)
  232.                 (LDB %%KBD-CONTROL-META CLICK))))
  233.  
  234. (DEFUN LOOKUP-STATE-NAME (STATE &OPTIONAL (COMTAB MOUSE-STATE-NAMES))
  235.   (AND (FIXNUMP STATE)
  236.        (>= (LDB %%KBD-MOUSE-BUTTON STATE) 0)
  237.        (<= (LDB %%KBD-MOUSE-BUTTON STATE) 2.)
  238.        (>= (LDB %%KBD-CONTROL-META STATE) 0)
  239.        (<= (LDB %%KBD-CONTROL-META STATE) 15.)
  240.        (AREF COMTAB (LDB %%KBD-MOUSE-BUTTON STATE)
  241.                 (LDB %%KBD-MOUSE-UP-STATE STATE)
  242.                 (LDB %%KBD-CONTROL-META STATE))))
  243.  
  244. (DEFUN DEFINE-CLICK-NAME (CLICK-NAME CLICK COMTAB STATE-SPECIFIER)
  245.   (COND ((NUMBERP CLICK)
  246.      (ASET CLICK-NAME
  247.            COMTAB
  248.            (LDB %%KBD-MOUSE-BUTTON CLICK)
  249.            (LDB STATE-SPECIFIER CLICK)
  250.            (LDB %%KBD-CONTROL-META CLICK)))
  251.     (T
  252.      (FERROR "~S is a completely unknown type of Boxer Input." CLICK))))
  253.  
  254. (DEFUN DEFINE-CLICK-AND-ALL-ITS-SHIFTED-CLICK-NAMES (CLICK-NAME CLICK-CODE COMTAB
  255.                              STATE-SPECIFIER)
  256.   (LET* ((C-CLICK-NAME   (INTERN-IN-BU-PACKAGE (FORMAT NIL "CTRL-~A" CLICK-NAME)))
  257.      (M-CLICK-NAME   (INTERN-IN-BU-PACKAGE (FORMAT NIL "META-~A" CLICK-NAME)))
  258.      (C-M-CLICK-NAME (INTERN-IN-BU-PACKAGE (FORMAT NIL "CTRL-META-~A" CLICK-NAME)))
  259.  
  260.      (C-CLICK-CODE   (DPB 1 %%KBD-CONTROL-META CLICK-CODE))
  261.      (M-CLICK-CODE   (DPB 2 %%KBD-CONTROL-META CLICK-CODE))
  262.      (C-M-CLICK-CODE (DPB 3 %%KBD-CONTROL-META CLICK-CODE)))
  263.     
  264.     (DEFINE-CLICK-NAME (INTERN-IN-BU-PACKAGE CLICK-NAME) CLICK-CODE COMTAB STATE-SPECIFIER)
  265.     (DEFINE-CLICK-NAME C-CLICK-NAME   C-CLICK-CODE   COMTAB STATE-SPECIFIER)
  266.     (DEFINE-CLICK-NAME M-CLICK-NAME   M-CLICK-CODE   COMTAB STATE-SPECIFIER)
  267.     (DEFINE-CLICK-NAME C-M-CLICK-NAME C-M-CLICK-CODE COMTAB STATE-SPECIFIER)))
  268.  
  269. (DEFUN DEFINE-CLICK-AND-ALL-ITS-MULTIPLE-CLICK-NAMES (CLICK-NAME CLICK-CODE COMTAB)
  270.   (LET ((1-CLICK-NAME (FORMAT NIL "~A-ONCE" CLICK-NAME))
  271.     (2-CLICK-NAME (FORMAT NIL "~A-TWICE" CLICK-NAME))
  272.  
  273.     (1-CLICK-CODE (DPB 0 %%KBD-MOUSE-N-CLICKS CLICK-CODE))
  274.     (2-CLICK-CODE (DPB 1 %%KBD-MOUSE-N-CLICKS CLICK-CODE)))
  275.     (DEFINE-CLICK-AND-ALL-ITS-SHIFTED-CLICK-NAMES
  276.       1-CLICK-NAME 1-CLICK-CODE COMTAB %%KBD-MOUSE-N-CLICKS)
  277.     (DEFINE-CLICK-AND-ALL-ITS-SHIFTED-CLICK-NAMES
  278.       2-CLICK-NAME 2-CLICK-CODE COMTAB %%KBD-MOUSE-N-CLICKS)))
  279.  
  280. (DEFUN DEFINE-INPUT-STATE-AND-ALL-ITS-MULTIPLE-STATE-NAMES (STATE-NAME STATE-CODE COMTAB)
  281.   (LET ((1-STATE-NAME (FORMAT NIL "~A-DOWN" STATE-NAME))
  282.     (2-STATE-NAME (FORMAT NIL "~A-UP" STATE-NAME))
  283.  
  284.     (1-STATE-CODE (DPB 0 %%KBD-MOUSE-UP-STATE STATE-CODE))
  285.     (2-STATE-CODE (DPB 1 %%KBD-MOUSE-UP-STATE STATE-CODE)))
  286.     (DEFINE-CLICK-AND-ALL-ITS-SHIFTED-CLICK-NAMES
  287.       1-STATE-NAME 1-STATE-CODE COMTAB %%KBD-MOUSE-UP-STATE)
  288.     (DEFINE-CLICK-AND-ALL-ITS-SHIFTED-CLICK-NAMES
  289.       2-STATE-NAME 2-STATE-CODE COMTAB %%KBD-MOUSE-UP-STATE)))
  290.  
  291. (DEFUN DEFINE-NAMES-FOR-EACH-MOUSE-BUTTON (&OPTIONAL
  292.                        (COMTAB MOUSE-CLICK-NAMES)
  293.                        (DEF-FCN
  294.                          'DEFINE-CLICK-AND-ALL-ITS-MULTIPLE-CLICK-NAMES)
  295.                        (DEVICE "MOUSE")
  296.                        (CLICK-CODE (DPB 1 %%KBD-MOUSE 0)))
  297.   "This is the top level function to call in order to define symbolic names for clicks on
  298.    a pointing device.  It will make symbolic names for left,middle,right and single,double
  299.    or shifted clicks on some input device. "
  300.   (LET ((L-CLICK-NAME (FORMAT NIL "~A-LEFT" DEVICE))
  301.     (M-CLICK-NAME (FORMAT NIL "~A-MIDDLE" DEVICE))
  302.     (R-CLICK-NAME (FORMAT NIL "~A-RIGHT" DEVICE))
  303.     
  304.         (L-CLICK-CODE (DPB 0 %%KBD-MOUSE-BUTTON CLICK-CODE))
  305.     (M-CLICK-CODE (DPB 1 %%KBD-MOUSE-BUTTON CLICK-CODE))
  306.     (R-CLICK-CODE (DPB 2 %%KBD-MOUSE-BUTTON CLICK-CODE)))
  307.     (FUNCALL DEF-FCN L-CLICK-NAME L-CLICK-CODE COMTAB)
  308.     (FUNCALL DEF-FCN M-CLICK-NAME M-CLICK-CODE COMTAB)
  309.     (FUNCALL DEF-FCN R-CLICK-NAME R-CLICK-CODE COMTAB)))
  310.  
  311. (EVAL-WHEN (LOAD)
  312.   (DEFINE-NAMES-FOR-EACH-MOUSE-BUTTON)
  313.   (DEFINE-NAMES-FOR-EACH-MOUSE-BUTTON
  314.     MOUSE-STATE-NAMES 'DEFINE-INPUT-STATE-AND-ALL-ITS-MULTIPLE-STATE-NAMES)
  315.   )
  316.  
  317. (DEFUN (:PROPERTY :MOUSE-CLICK :BOXER-INPUT) (BLIP)
  318.   (LET* ((WINDOW (SECOND BLIP))
  319.      (CLICK  (THIRD  BLIP))
  320.      (X-POS  (FOURTH BLIP))
  321.      (Y-POS  (FIFTH  BLIP))
  322.      (CLICK-NAME (LOOKUP-CLICK-NAME CLICK)))
  323.     (IF (BOXER-FDEFINED? CLICK-NAME)
  324.     (BOXER-FUNCALL CLICK-NAME WINDOW X-POS Y-POS)
  325.     (UNHANDLED-BOXER-INPUT CLICK))))
  326.  
  327. (DEFUN (:PROPERTY :MOUSE-HOLD :BOXER-INPUT) (BLIP)
  328.   (LET* ((WINDOW (SECOND BLIP))
  329.      (STATE  (THIRD  BLIP))
  330.      (X-POS  (FOURTH BLIP))
  331.      (Y-POS  (FIFTH  BLIP))
  332.      (STATE-NAME (LOOKUP-STATE-NAME STATE)))
  333.     (IF (BOXER-FDEFINED? STATE-NAME)
  334.     (BOXER-FUNCALL STATE-NAME WINDOW X-POS Y-POS)
  335.     (UNHANDLED-BOXER-INPUT STATE))))
  336.  
  337. ;;; Documentation Support
  338. (DEFMACRO RECORD-COMMAND-KEY (KEY-NAME COMMAND-NAME)
  339.   `(EVAL-WHEN (COMPILE LOAD EVAL)
  340.      (WHEN (NOT (NULL (ASSQ ,KEY-NAME *BOXER-COMMAND-KEY-ALIST*)))
  341.        (SETQ *BOXER-COMMAND-KEY-ALIST*
  342.          (DELQ (ASSQ ,KEY-NAME *BOXER-COMMAND-KEY-ALIST*) *BOXER-COMMAND-KEY-ALIST*)))
  343.      (PUSH (CONS ,KEY-NAME ,COMMAND-NAME) *BOXER-COMMAND-KEY-ALIST*)))
  344.  
  345. ;; Note that while there might be several keys for one command, 
  346. ;; there can only be one command for each key (at top level)
  347.  
  348. (DEFUN GET-COMMAND-FOR-KEY (KEY-NAME)
  349.   (CDR (ASSQ KEY-NAME *BOXER-COMMAND-KEY-ALIST*)))
  350.  
  351. (DEFUN GET-KEYS-FOR-COMMAND (COMMAND)
  352.   (LOOP FOR PAIR IN *BOXER-COMMAND-KEY-ALIST*
  353.     WHEN (EQ COMMAND (CDR PAIR))
  354.       COLLECT (CAR PAIR)))
  355.  
  356. ;;; Input history
  357.  
  358. (DEFUN DECODE-INPUT-FOR-PRINTING (INPUT &OPTIONAL (STREAM NIL) &AUX (PREFIX ""))
  359.   (COND ((FIXP INPUT)
  360.      ;; must be a keystroke
  361.      (FORMAT STREAM "~A~A~%"
  362.          (PROG2 (COND-EVERY ((PLUSP (LDB %%KBD-CONTROL INPUT))
  363.                      (SETQ PREFIX (STRING-APPEND "CTRL-" PREFIX)))
  364.                     ((PLUSP (LDB %%KBD-META INPUT))
  365.                      (SETQ PREFIX (STRING-APPEND "META-" PREFIX)))
  366.                     ((PLUSP (LDB %%KBD-SUPER INPUT))
  367.                      (SETQ PREFIX (STRING-APPEND "SUPER-" PREFIX)))
  368.                     ((PLUSP (LDB %%KBD-HYPER INPUT))
  369.                      (SETQ PREFIX (STRING-APPEND "HYPER-" PREFIX))))
  370.             PREFIX)
  371.          (COND ((= #O40 (LDB %%KBD-CHAR INPUT))
  372.             "SPACE")
  373.                ((= #O215 (LDB %%KBD-CHAR INPUT))
  374.             "RETURN")
  375.                (T (FORMAT NIL "~C" (LDB %%KBD-CHAR INPUT))))))
  376.     ((LISTP INPUT)
  377.      ;; some sort of BLIP, probably from the mouse
  378.      (DECODE-MOUSE-CLICK-FOR-PRINTING (THIRD INPUT) STREAM))    ;for now...
  379.     (T INPUT)))
  380.  
  381. (DEFUN DECODE-MOUSE-CLICK-FOR-PRINTING (CLICK &OPTIONAL (STREAM NIL) &AUX (PREFIX ""))
  382.   (FORMAT STREAM "~AMOUSE-~A~D~%"
  383.       (PROG2 (COND-EVERY ((PLUSP (LDB %%KBD-CONTROL CLICK))
  384.                   (SETQ PREFIX (STRING-APPEND "CTRL-" PREFIX)))
  385.                  ((PLUSP (LDB %%KBD-META CLICK))
  386.                   (SETQ PREFIX (STRING-APPEND "META-" PREFIX)))
  387.                  ((PLUSP (LDB %%KBD-SUPER CLICK))
  388.                   (SETQ PREFIX (STRING-APPEND "SUPER-" PREFIX)))
  389.                  ((PLUSP (LDB %%KBD-HYPER CLICK))
  390.                   (SETQ PREFIX (STRING-APPEND "HYPER-" PREFIX))))
  391.          PREFIX)
  392.       (COND ((= 0 (LDB %%KBD-MOUSE-BUTTON CLICK))
  393.          "LEFT-")
  394.         ((= 1 (LDB %%KBD-MOUSE-BUTTON CLICK))
  395.          "MIDDLE-")
  396.         ((= 2 (LDB %%KBD-MOUSE-BUTTON CLICK))
  397.          "RIGHT-"))
  398.       (1+ (LDB %%KBD-MOUSE-N-CLICKS CLICK))))
  399.  
  400. (DEFUN PRINT-KEYSTROKES (&OPTIONAL (LAST-N (LENGTH *BOXER-KEYSTROKE-HISTORY*)))
  401.   (TERPRI STANDARD-OUTPUT)
  402.   (LOOP FOR INDEX FROM LAST-N DOWNTO 1
  403.     DO (DECODE-INPUT-FOR-PRINTING (NTH INDEX *BOXER-KEYSTROKE-HISTORY*)
  404.                       STANDARD-OUTPUT)))
  405.  
  406. (DEFUN DUMP-KEYSTROKES (BUFFER-NAME &OPTIONAL(LAST-N (LENGTH *BOXER-KEYSTROKE-HISTORY*)))
  407.   (ZWEI:WITH-EDITOR-STREAM (EDITOR-STREAM ':BUFFER-NAME BUFFER-NAME ':CREATE-P T)
  408.     (LOOP FOR INDEX FROM (- (LENGTH *BOXER-KEYSTROKE-HISTORY*) LAST-N)
  409.                 TO   (1- (LENGTH *BOXER-KEYSTROKE-HISTORY*))
  410.       DO (DECODE-INPUT-FOR-PRINTING (NTH INDEX *BOXER-KEYSTROKE-HISTORY*)
  411.                     EDITOR-STREAM))))
  412.